home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN2.LZH / STD.FOR < prev    next >
Text File  |  1988-02-08  |  7KB  |  207 lines
  1.       SUBROUTINE STD ( FACTS, TOKE, NTOKE, ERR )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **           STD             **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          STANDARDIZE
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS 207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CALIF   94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          TO REPLACE NON-STANDARD UNITS WITH THEIR EQUIVALENT
  23. C*          STANDARD UNITS AND RESULTING SCALE FACTOR.
  24. C*
  25. C*     METHODOLOGY :
  26. C*          NA
  27. C*
  28. C*     INPUT ARGUMENTS :
  29. C*          TOKE  - ARRAY OF (POTENTIALLY) NON-STANDARD UNITS
  30. C*          NTOKE - NUMBER OF ENTRIES IN TOKE
  31. C*
  32. C*     OUTPUT ARGUMENTS :
  33. C*          TOKE  - THE ARRAY WITH ONLY STANDARD UNITS
  34. C*          NTOKE - NUMBER OF ENTRIES IN TOKE
  35. C*          FACTS - ARRAY WITH SCALE FACTORS FOR EACH UNIT IN TOKE
  36. C*          ERR   - SET TRUE IF A UNIT COULD NOT BE FOUND
  37. C*
  38. C*     INTERNAL WORK AREAS :
  39. C*          TEMP  - USED TO STORE TOKENS UNTIL ALL UNITS ARE REPLACED
  40. C*
  41. C*     COMMON BLOCKS :
  42. C*          NONE
  43. C*
  44. C*     FILE REFERENCES :
  45. C*          NONE
  46. C*
  47. C*     SUBPROGRAM REFERENCES :
  48. C*          NONE
  49. C*
  50. C*     ERROR PROCESSING :
  51. C*          IF A UNIT ISN'T FOUND, ABORT.
  52. C*
  53. C*     TRANSPORTABILITY LIMITATIONS :
  54. C*          NONE
  55. C*
  56. C*     ASSUMPTIONS AND RESTRICTIONS :
  57. C*          NONE
  58. C*
  59. C*     LANGUAGE AND COMPILER :
  60. C*          ANSI FORTRAN 77
  61. C*
  62. C*     VERSION AND DATE :
  63. C*          VERSION I.0      7-FEB-85
  64. C*
  65. C*     CHANGE HISTORY :
  66. C*           7-FEB-85    INITIAL VERSION
  67. C*
  68. C***********************************************************************
  69. C*
  70.       PARAMETER (NUM=39)
  71.       CHARACTER *6 TOKE(1), TEMP(100), KNOWN(NUM), ALIAS(NUM),
  72.      $ LIST(100)
  73.       CHARACTER *1 FIRST
  74.       LOGICAL ERR
  75.       DOUBLE PRECISION FACTS(1), KFACT(NUM)
  76. C
  77. C --- KNOWN UNITS (BOTH STANDARD AND NON-STANDARD)
  78. C
  79. C --- NOTE: THE FOLLOWING ARRAY MUST BE IN ALPHABETIC ORDER
  80. C
  81.       DATA KNOWN /  'CM    ',    'FEET  ',    'FPS   ',    'FT    ',
  82.      $ 'GAL   ',    'GALLON',    'GM    ',    'GRAM  ',    'HOUR  ',
  83.      $ 'HP    ',    'HR    ',    'IN    ',    'INCH  ',    'KG    ',
  84.      $ 'KILOGR',    'KILOME',    'KM    ',    'KNOTS ',    'L     ',
  85.      $ 'LB    ',    'LITER ',    'M     ',    'METER ',    'MI    ',
  86.      $ 'MILE  ',    'MIN   ',    'MINUTE',    'MPH   ',    'N     ',
  87.      $ 'NAUTMI',    'NEWTON',    'POUND ',    'PSI   ',    'S     ',
  88.      $ 'SEC   ',    'SECOND',    'SLUG  ',    'YD    ',    'YARD  '/
  89. C
  90. C --- THE CONVERSION FACTOR TO GET FROM 'KNOWN' TO 'ALIAS'
  91. C
  92. C --- IMPORTANT!!! THE CONVERSION FACTORS FOR 'GAL' AND 'LITER' ARE
  93. C ---  THE CUBE ROOT OF THE ACTUAL CONVERSION FACTOR SINCE 'EVAL' WILL
  94. C ---  CUBE THEM WHEN IT SEES 'FT^3'.
  95. C
  96.       DATA KFACT /  3.28084D-2,  1.0D0,       1.0D0,       1.0D0,
  97.      $5.11317368D-1,5.11317368D-1,6.852166D-5, 6.852166D-5, 3.6D3,
  98.      $5.5D2,        3.6D3,       8.3333333D-2,8.3333333D-2,6.852166D-2,
  99.      $6.852166D-2,  3.28084D3,   3.28084D3,   1.68780648D0,3.2808719D-2,
  100.      $1.0D0,        3.2808719D-2,3.28084D0,   3.28084D0,   5.28D3,
  101.      $5.28D3,       6.0D1,       6.0D1,       1.4666667D0, 2.2046226D0,
  102.      $6.0761157D3,  2.2046226D0, 1.0D0,       6.9444444D-3,1.0D0,
  103.      $1.0D0,        1.0D0,       1.0D0,       3.0D0,       3.0D0/
  104. C
  105. C --- THE EQUIVALENT STANDARD UNIT OR POINTER INTO 'LIST'
  106. C
  107.       DATA ALIAS /  'FT    ',    'FT    ',    '-   21',    'FT    ',
  108.      $ '-   27',    '-   27',    'SLUG  ',    'SLUG  ',    'SEC   ',
  109.      $ '-    1',    'SEC   ',    'FT    ',    'FT    ',    'SLUG  ',
  110.      $ 'SLUG  ',    'FT    ',    'FT    ',    '-    9',    '-   33',
  111.      $ 'LB    ',    '-   33',    'FT    ',    'FT    ',    'FT    ',
  112.      $ 'FT    ',    'SEC   ',    'SEC   ',    '-   15',    'LB    ',
  113.      $ 'FT    ',    'LB    ',    'LB    ',    '-   39',    'SEC   ',
  114.      $ 'SEC   ',    'SEC   ',    'SLUG  ',    'FT    ',    'FT    '/
  115. C
  116. C --- THIS LIST IS USED WHEN A NON-STANDARD UNIT MUST BE REPLACED BY A
  117. C ---  LIST OF STANDARD UNITS (EG, 'HP' = 'FT-LB/SEC')
  118. C
  119.       DATA LIST  /  '(     ',   'FT    ',   '*     ',   'LB    ',
  120.      $ '/     ',    'SEC   ',   ')     ',   '$     ',   '(     ',
  121.      $ 'FT    ',    '/     ',   'SEC   ',   ')     ',   '$     ',
  122.      $ '(     ',    'FT    ',   '/     ',   'SEC   ',   ')     ',
  123.      $ '$     ',    '(     ',   'FT    ',   '/     ',   'SEC   ',
  124.      $ ')     ',    '$     ',   '(     ',   'FT    ',   '^     ',
  125.      $ '3     ',    ')     ',   '$     ',   '(     ',   'FT    ',
  126.      $ '^     ',    '3     ',   ')     ',   '$     ',   '(     ',
  127.      $ 'LB    ',    '/     ',   'FT    ',   '^     ',   '2     ',
  128.      $ ')     ',    '$     ',
  129.      $ 54*'      '/
  130. C
  131.       ITOKE = 1
  132.       IFAC  = 1
  133.       DO 100 I = 1, NTOKE
  134. C
  135. C --- IF THE TOKEN REPRESENTS A UNIT, BINARY SEARCH UNITS LIST
  136. C
  137.          FIRST = TOKE(I)(1:1)
  138.          IF ((FIRST .GE. 'A') .AND. (FIRST .LE. 'Z')) THEN
  139. C
  140. C --- BINARY SEARCH KNOWN UNITS LIST
  141. C
  142.             II = 1
  143.             J = NUM
  144. 10          K = (II + J) / 2
  145.             IF (TOKE(I) .LE. KNOWN(K)) J = K - 1
  146.             IF (TOKE(I) .GE. KNOWN(K)) II = K + 1
  147.             IF (II .LE. J) GO TO 10
  148.             IF (II-1 .LE. J) THEN
  149. C
  150. C --- IF NOT FOUND, SET ERROR AND RETURN
  151. C
  152.                ERR = .TRUE.
  153.                RETURN
  154.             ENDIF
  155. C
  156. C --- FOUND... PUT IN SCALE FACTOR (1 IF ALREADY STANDARD)
  157. C ---  IF NOT STANDARD, PACK REPLACEMENT UNITS IN TEMP
  158. C
  159.             IF (ALIAS(K)(1:1) .EQ. '-') THEN
  160.                READ(ALIAS(K)(2:6),900) IPTR
  161.                ISTORE = IFAC
  162. 20             FACTS(IFAC) = 1.0D0
  163.                IFAC = IFAC + 1
  164.                TEMP(ITOKE) = LIST(IPTR)
  165.                ITOKE = ITOKE + 1
  166.                IPTR = IPTR + 1
  167.                IF (LIST(IPTR) .NE. '$') GO TO 20
  168.                FACTS(ISTORE+1) = KFACT(K)
  169.             ELSE
  170.                FACTS(IFAC) = KFACT(K)
  171.                IFAC  = IFAC + 1
  172.                TEMP(ITOKE) = ALIAS(K)
  173.                ITOKE = ITOKE + 1
  174.             ENDIF
  175. C
  176. C --- IF THE TOKEN IS A NUMBER (EXPONENT) PASS A 1.
  177. C ---  (THIS IS NEEDED SINCE 'EVAL' PASSES EXPONENTS TO THE STACK
  178. C
  179.          ELSE IF((FIRST .GE. '0') .AND. (FIRST .LE. '9')) THEN
  180.             TEMP(ITOKE) = TOKE(I)
  181.             ITOKE = ITOKE + 1
  182.             FACTS(IFAC) = 1.0D0
  183.             IFAC  = IFAC + 1
  184. C
  185. C --- OTHERWISE, ITS AN OPERATOR
  186. C
  187.          ELSE
  188.             TEMP(ITOKE) = TOKE(I)
  189.             ITOKE = ITOKE + 1
  190.             FACTS(IFAC) = 1.0D0
  191.             IFAC = IFAC + 1
  192.          ENDIF
  193. 100      CONTINUE
  194. C
  195. C --- COPY FROM TEMP STORAGE BACK TO TOKE
  196. C
  197.       NTOKE = ITOKE - 1
  198.       DO 200 I = 1, NTOKE
  199.          TOKE(I) = TEMP(I)
  200. 200      CONTINUE
  201.       RETURN
  202. 900   FORMAT(I5)
  203.       END
  204. C
  205. C---END STD
  206. C
  207.